COMMENT ⊗   VALID 00004 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	 A Metering System for MacLisp
C00015 00003	(defun meter:pass1 (form)
C00031 00004	 Here's a typical file:
C00035 ENDMK
C⊗;
;;; A Metering System for MacLisp

(declare (special meter:meters meter:max meter:comments meter:meterp
		  meter:max-max meter:maxf meter:factor meter:array-name
		  meter:array-size meter:start-time meter:end-time meter:inc-only
		  meter:all-comments meter:local-max meter:real-runtime
		  meter:comment-name meter:fun-names meter:name meter:count-only
		  meter:inc-onlys meter:funs
		  meter:count-array-name)
	 (mapex t)
	 (*lexpr %match)
	 (flonum meter:real-runtime)
	 (fixnum meter:max-max meter:max)) 

(eval-when (compile eval)
	   (setq meter:meters () meter:fun-names ()
		 meter:funs ()
		 meter:all-comments () meter:comments ()))

(eval-when (load eval)
	   (cond ((not (boundp 'meter:count-only))
		  (setq meter:count-only ()))))

(eval-when (load)
	   (cond ((boundp 'meter:meters))
		 (t (setq meter:meters ()))))

;;; (meter (defun foo ... (m "Baz"))...)
;;; (m "Foo") 	adds 1 to the "Foo" counter
;;; (m "Foo" 3) adds 3 to the "Foo" counter
;;; (m "Foo" 3 (foo a b c)) adds 3 to the "Foo" counter and counts the runtime
;;; (mn "Foo" foo) adds 1 to the foo counter
;;; (mn "Foo" foo 3) adds 3 to the foo counter
;;; (mn "Foo" foo 3 (foo a b c)) adds 3 to the foo counter and counts the runtime
;;;	in all cases the counts are listed as "Foo"
;;;  the indexed ones (mn ...) are so that PUSH can be counted as a CONS.

;;;						      the index for this entry
;;;							 |
;;;							 | number to increment by
;;; (meter-funs						 ↓   ↓
;;;  ((zerop "Zerop")(1- "1-") (* "Times")(PUSH "CONSs" CONS 2))
;;; 		  (defun fact (n)			 ↑   ↑ 
;;; 			 (cond ((zerop n) 1)		optionals
;;; 			       (t (* n (fact (1- n)))))))

;;; METER:COUNT-ONLY, defaultly (), is T if you want to only count the
;;; number of forms evaluated,  skipping the runtime info.

;;; Do (FMETER:METER <name><file>)
;;; (setq meter:funs '(....)) ala (METER-FUNS (...) ...)

(defun meter:make-name (symbol)
       (implode (append (explode symbol)
			'(-)
			(explode meter:name))))

;;; F is a form. L is an alist
(defun meter:assoc-1 (f l avoid)
       (do ((l l (cdr l)))
	   ((null l) ())
	   (cond ((and (equal (car f) (caar l))
		       (not (memq (car l) avoid)))
		  (return (car l)))
		 ((atom (caar l)))
		 ((and (%match (caar l) f)
		       (not (memq (car l) avoid)))
		  (return (car l))))))

(defun fmeter:meter (name file)
       (setq meter:name name)
       (setq meter:maxf (meter:make-name 'meter:maxf)
	     meter:array-name (meter:make-name 'meter:array-name)
	     meter:count-array-name (meter:make-name 'meter:count-array-name)
	     meter:array-size (meter:make-name 'meter:array-size)
	     meter:factor (meter:make-name 'meter:factor)
	     meter:comment-name (meter:make-name 'meter:comment-name)
	     meter:inc-onlys ()
	     meter:max-max 0)
       (set  meter:comment-name
	     (implode (append '(m e t e r :)
			      (explode name)
			      '(- c o m m e n t))) )
       (set meter:array-name
	    (implode (append '(m e t e r :)
			     (explode name) 
			     '(- a r r a y))))
       (cond (meter:count-only
	      (set meter:count-array-name
		   (implode (append '(m e t e r :)
				    (explode name) 
				    '(- c o u n t - a r r a y))))))
       (set meter:maxf -1)
       (setq meter:start-time (meter:make-name 'meter:start-time)
	     meter:end-time (meter:make-name 'meter:end-time)
	     meter:inc-only (meter:make-name 'meter:inc-only))
       (setq meter:fun-names ()
	     meter:all-comments ()
	     meter:comments ())
       (let* ((ifilename (defaultf file))
	      (todelete ())
	      (ofilename (mergef '(* fm1) ifilename)))
	    (cond ((probef ofilename)(deletef ofilename)))
	    (push ofilename todelete)
	    (let ((ifle (eopen ifilename '(in ascii)))
		  (ofle (open ofilename '(out ascii)))
		  (eof (ncons ())))
	     (do ((form (read ifle eof)
			(read ifle eof)))
		 ((eq form eof) 
		  (close ofle)(close ifle)
		  (setq ifilename ofilename)
		  (setq ifle (open ifilename '(in ascii)))
		  (setq ofilename
			(mergef '(* fm2) ifilename))
		  (push ofilename todelete)
		  (cond ((probef ofilename)(deletef ofilename)))
		  (setq ofle (open ofilename '(out ascii)))
		  (do ((form (read ifle eof)(read ifle eof)))
		      ((eq form eof)
		       (close ofle)(close ifle)
		       (setq ifilename ofilename)
		       (setq ofilename
			     (mergef '(* fmt) ifilename))
		       (cond ((probef ofilename)(deletef ofilename)))
		       (setq ifle (open ifilename '(in ascii)))
		       (setq ofle (open ofilename '(out ascii)))
		       (cond ((> (symeval meter:maxf) -1)
			      (meter:prologue ofle)))
		       (do ((form (read ifle eof)(read ifle eof)))
			   ((eq form eof)
			    (cond ((> (symeval meter:maxf) -1)
				   (terpri ofle)
				   (princ "(include " ofle)
			           (tyo 34. ofle)
				   (princ "metaux.lsp[tim,lsp]" ofle)
				   (tyo 34. ofle)
				   (princ ")" ofle)(terpri ofle)))
			    (mapc #'deletef todelete)
			    (close ifle)
			    (close ofle))
			   ----
			   (print form ofle)
			   ---))
		      (print (meter:pass2 form) ofle)
		      (set meter:array-size 
			   (* (1+ (symeval meter:maxf))
			      (1+ meter:max-max)))))
		 ----
		 (mapc #'(lambda (x)(print x ofle))
		       (meter:pass1 form)) 
		 (set meter:factor (1+ meter:max-max))
		 ---))))

(defun meter:prologue (ofile)
       (mapc 
	#'(lambda (x)
		  (print x ofile))
	`(
	  (eval-when (compile)
		     (setq meter:name (quote ,meter:name))
		     (setq meter:factor (quote ,meter:factor))
		     (setq meter:count-only (quote ,meter:count-only))
		     (defun meter:make-name (symbol)
			    (implode (append (explode symbol)
					     '(-)
					     (explode meter:name)))))
	  (declare (array* (notype ,(symeval meter:comment-name)
				   2)
			   (fixnum ,(symeval meter:array-name)
				   1) 
			   ,@(cond (meter:count-only
				    `((fixnum ,(symeval 
						meter:count-array-name)
					      1)))))
		   (fixnum ,meter:factor 
			   ,meter:array-size)
		   (special ,meter:factor 
			    ,meter:array-size 
			    ,meter:inc-only
			    ,meter:array-name
			    ,meter:count-array-name
			    ,meter:maxf 
			    ,meter:comment-name
			    meter:real-runtime)
		   (*expr ,(meter:make-name 'meter:start-time)
			  ,(meter:make-name 'meter:inc-only)
			  ,(meter:make-name 'meter:end-time) ))
	  (array ,(symeval meter:comment-name) t 
		 ,(+ 2 (symeval meter:maxf))
		 ,(+ 2 meter:max-max))
	  (eval-when (compile load eval)
		     (setq ,(meter:make-name 'meter:array-size)
			   ,(* (1+ (symeval meter:maxf))
			       (1+ meter:max-max))))
	  (setq ,meter:inc-only (quote ,meter:inc-onlys))
	  (array ,(symeval meter:array-name)
		 fixnum ,(1+ (symeval meter:maxf)))
	  ,@(cond (meter:count-only
		   `((array ,(symeval meter:count-array-name)
			    fixnum 
			    ,(* (1+ (symeval meter:maxf))
				(1+ meter:max-max))))))
	  (do ((i ,(symeval meter:maxf) (1- i)) 
	       (a (quote ,meter:fun-names) (cdr a))
	       (b (quote ,meter:all-comments) (cdr b)))
	      ((< i 0) ())
	      (store (,(symeval meter:comment-name) i 0) 
		     (car a))
	      (store (,(symeval meter:array-name) i)
		     (cadr (let ((f (car a))(l ',meter:meters))
				 (do ((l l (cdr l)))
				     ((null l) ())
				     (cond ((equal f (caar l))
					    (return (car l)))
					   ((atom (caar l)))
					   ((%match (caar l) f)
					    (return (car l))))))))
	      ,@(cond (meter:count-only
		       `((store (,(symeval meter:count-array-name) i)
				0))))
	      (do ((j 1 (1+ j))
		   (c (reverse (car b)) (cdr c)))
		  ((null c) ())
		  (store (,(symeval meter:comment-name) i j) 
			 (cadr (car c))))) 
	  (setq ,meter:factor
		,(1+ meter:max-max))
	  ,@(cond (meter:count-only
		   `((setq ,meter:count-array-name
			   (quote ,(symeval meter:count-array-name))))))
	  (setq ,meter:array-name
		(quote ,(symeval meter:array-name))
		,meter:maxf ,(symeval meter:maxf)
		,meter:comment-name 
		(quote ,(symeval meter:comment-name)))))
       t)
(defun meter:pass1 (form)
       (cond ((atom form) `(,form))
	     (t (caseq (car form)
		       (meter-funs
			(cond ((and (boundp 'meter:meterp)
				    (not meter:meterp))
			       (cdr form))
			      (t
			       (let ((funs (cadr form)))
				    (meter:pass1-a
				     (mapcar 
				      #'(lambda (f) 
						(cond ((memq (car f) '(defun defmacro))
						       `(,(car f) ,(cadr f) 
								  ,(caddr f)
								  ,@(meter:meter-funs 
								     funs
								     () (cdddr f))))
						      (t f)))
				      (cddr form)))))))
		       (meter
			(cond ((and (boundp 'meter:meterp)
				    (not meter:meterp))
			       (cdr form))
			      (t
			       (meter:pass1-a (cdr form)))))
		       (t (cond (meter:funs
				 (cond ((and (boundp 'meter:meterp)
					     (not meter:meterp))
					form)
				       (t
					(meter:pass1-a
					 (cond ((memq (car form) '(defun defmacro))
						`((,(car form) ,(cadr form) 
								  ,(caddr form)
								  ,@(meter:meter-funs 
								     meter:funs
								     () (cdddr form)))))
						      (t form))))))
				(t `(,form))))))))
					   
(defun meter:pass1-a (funs)
       (let ((name (cadr (car funs))))
	    (set meter:maxf (1+ (symeval meter:maxf)))
	    (setq meter:max -1)
	    (prog1
	     (mapcar #'(lambda (f)
			       (cond ((memq (car f) '(defun defmacro))
				      `(defun
					,(cadr f)
					,(caddr f)
					.,(meter:process 
					   meter:array-name 
					   (cdddr f))))
				     (t f)))
		     funs)
	     (push name meter:fun-names)
	     (push 
	      meter:comments
	      meter:all-comments)
	     (setq meter:comments ())
	     (let ((entry (assoc name meter:meters)))
		  (cond (entry (rplaca (cdr entry) meter:max))
			(t 
			 (push 
			  `(,name ,meter:max)
			  meter:meters))))
	     (setq meter:max-max (max meter:max-max meter:max)))))
			   
(defun meter:pass2 (fun)
       (meter:pass2-a fun) fun))
					 
(defun meter:pass2-a (fun)
       (cond ((null fun) ())
	     ((atom fun) ())
	     ((numberp fun) ())
	     ((eq (car fun) meter:end-time)
	      (rplacd fun `(,(+ (* (symeval meter:factor) (cadr fun))
				(caddr fun)) ,(cadddr fun))))
	     ((eq (car fun) meter:inc-only)
	      (let ((x 
		     (+ (* (symeval meter:factor) (cadr fun))
			(caddr fun))))
		   (push x meter:inc-onlys)
		   (rplacd fun `(,x ,(cadddr fun)))))
	     ((eq (car fun) 'meter:inc)
	      (rplacd (cdr fun) `(,(+ (* (symeval meter:factor) (caddr fun))
				      (cadddr fun)) ,(cadddr (cdr fun)))))
	     
	     (t (mapc #'meter:pass2-a fun))))
					 
					 (defmacro meter:expr-p (f)
						   `(do ((l (plist (car ,f)) (cddr l)))
							((null l) t)
							(cond ((memq (car l) '(expr *expr subr lsubr)) (return t))
							      ((memq (car l) '(fexpr *fexpr fsubr macro)) (return ())))))
					 
(defmacro meter:special-case-p (f)
	  `(get (car ,f) 'meter:expand-code))

(defun meter:bindable-form (l avoid form)
       (cond ((atom form) ())
	     ((numberp form) ())
	     ((meter:expr-p form)
	      (let ((args ()))
		   `(,(mapcan #'(lambda (x)
					(cond ((or (atom x) 
						   (null x)
						   (numberp x)
						   (eq (car x) 'quote))
					       (push x args) ())
					      (t (let ((x (gensym)))
						      (push x args)
						      (ncons x)))))
			      (cdr form)) 
		     (,(car form) . ,(reverse args))
		     ,(mapcan #'(lambda (x)
					(cond ((or (atom x) 
						   (null x)
						   (numberp x)
						   (eq (car x) 'quote))
					       ())
					      (t `(,x))))
			      (cdr form)))))
	     (t (let ((handler (meter:special-case-p form)))
		     (cond (handler (funcall handler form l avoid)))))))

(defun meter:meter-funs (l avoid f)
       (cond ((null f) ())
	     ((atom f) f)
	     ((numberp f) f)
	     ((memq (car f) '(mn m))
	      (caseq (length f)
		     ((1 2 3 4) f)
		     (5 `(,(car f) ,(cadr f) ,(caddr f) ,(cadddr f)
				   ,(meter:meter-funs l avoid (cadddr (cdr f)))))
		     (t f)))
	     (t (let ((entry (meter:assoc-1 f l avoid)))
		     (cond (entry
			    (let ((q (meter:bindable-form l avoid f)))
				 (cond ((and q (car q))
					`((lambda ,(car q)
						  (mn 
						   ,(cadr entry) 
						   ,(or (caddr entry)
							(car entry))
						   ,(or (cadddr entry) 1)
						   ,(cadr q)))
					  . ,(mapcar 
					      #'(lambda (x)
							(meter:meter-funs
							 l avoid x))
					      (caddr q))))
				       (t
					`(mn ,(cadr entry) ,(or (caddr entry)
								(car entry))
					     ,(or (cadddr entry) 1)
					     ,(meter:meter-funs 
					       l `(,entry . ,avoid) f))))))
			   ((eq (car f) 'store)
			    `(store ,(cadr f) ,(meter:meter-funs l avoid (caddr f))))
			   ((eq (car f) 'quote) f)
			   (t (mapcar #'(lambda (f)
						(meter:meter-funs l avoid f))
				      f)))))))

(defun meter:process (a f)
       (cond ((null f) ())
	     ((atom f) f)
	     ((numberp f) f)
	     ((eq (car f) 'm)
	      (let* ((form ())
		     (inc (cond ((null (cddr f)) 1)
				((null (cdddr f))
				 (caddr f))
				(t 
				 (setq form (cadddr f))
				 (caddr f)))))
		    (setq meter:max (1+ meter:max))
		    (push `(() ,(cadr f)
			       ,(symeval meter:maxf) ,meter:max
			       ,inc)
			  meter:comments)
		    (cond (form
			   (cond (meter:count-only
				  `(progn (meter:inc 
					   ,(symeval meter:count-array-name)
					   ,(symeval meter:maxf)
					   ,meter:max ,inc)  
					  ,(meter:process a form)))
				 (t `(prog2 (,meter:start-time)
					    ,(meter:process a form)
					    (,meter:end-time
					     ,(symeval meter:maxf)
					     ,meter:max ,inc))) ))
			  (t (cond (meter:count-only
				    `(meter:inc ,(symeval meter:count-array-name)
						,(symeval meter:maxf)
						,meter:max ,inc))
				   (t `(,meter:inc-only ,(symeval meter:maxf)
							,meter:max ,inc)))))))
	     ((eq (car f) 'mn)
	      (let* ((index (caddr f))
		     (entry (assoc index meter:comments))
		     (form ())
		     (inc (cond ((null (cdddr f)) 1)
				((null (cdr (cdddr f)))
				 (caddr (cdr f)))
				(t 
				 (setq form (cadddr (cdr f)))
				 (caddr (cdr f)))))
     		     (args
		      (cond (entry 
			     (cddr entry))
			    (t (setq meter:max (1+ meter:max))
			       (push `(,index ,(cadr f)
					      ,(symeval meter:maxf)
					      ,meter:max ,inc)
				     meter:comments)
			       `(,(symeval meter:maxf) ,meter:max ,inc)))))
		    (cond (form
			   (cond (meter:count-only
				  `(progn (meter:inc ,(symeval meter:count-array-name)
						     .,args)
					  ,(meter:process a form)))
				 (t `(prog2 (,meter:start-time) ,(meter:process a form)
					    (,meter:end-time .,args)))))
			  (t 
			   (cond (meter:count-only
				  `(meter:inc ,(symeval meter:count-array-name) .,args))
				 (t `(,meter:inc-only .,args)))))))
	     ((eq (car f) 'store)
	      `(store ,(cadr f) ,(meter:process a (caddr f))))
	     ((eq (car f) 'quote) f)
	     ((eq (car f) 'do)
	      `(do ,(mapcar #'(lambda (x)
				      `(,(car x)
					. ,(mapcar #'(lambda (f)
							     (meter:process a f))
						   (cdr x))))
			    (cadr f))
		   ,(mapcar #'(lambda (x) (meter:process a x)) (caddr f))
		   . ,(mapcar #'(lambda (x) (meter:process a x)) (cdddr f))))  
	     ((eq (car f) 'let)
	      `(let ,(mapcar #'(lambda (x)
				       (cond ((atom x) x)
					     (t `(,(car x)
						  ,(meter:process a (cadr x))))))
			     (cadr f))
		    . ,(mapcar#'(lambda (q)
					(meter:process a q))
				(cddr f))))
	     ((memq (car f) '(lambda prog))
	      `(,(car f) ,(cadr f)
		       . ,(mapcar#'(lambda (q)
					   (meter:process a q))
				   (cddr f))))
	     (t (mapcar #'(lambda (f) (meter:process a f))
			f))))

(defun meter:unprocess (f)
       (cond ((null f) ())
	     ((atom f) f)
	     ((numberp f) f)
	     ((eq (car f) 'quote) f)
	     ((eq (car f) 'do)
	      `(do ,(mapcar #'(lambda (x)
				      `(,(car x)
					. ,(mapcar #'(lambda (f)
							     (meter:unprocess f))
						   (cdr x))))
			    (cadr f))
		   ,(mapcar #'(lambda (x) (meter:unprocess x)) (caddr f))
		   . ,(mapcar #'(lambda (x) (meter:unprocess x)) (cdddr f))))  
	     ((eq (car f) 'let)
	      `(let ,(mapcar #'(lambda (x)
				       (cond ((atom x) x)
					     (t `(,(car x)
						  ,(meter:unprocess (cadr x))))))
			     (cadr f))
		    . ,(mapcar#'(lambda (q)
					(meter:unprocess q))
				(cddr f))))
	     ((memq (car f) '(lambda prog))
	      `(,(car f) ,(cadr f)
		       . ,(mapcar#'(lambda (q)
					   (meter:unprocess q))
				   (cddr f))))
	     ((atom (car f))
	      `(,(car f) . ,(meter:unprocess (cdr f))))
	     ((eq (caar f) 'm)
	      (let ((form 
		      (cond ((null (cddr (car f))) ())
			    ((null (cdddr (car f)))
				 ())
			    (t 
			     (cadddr (car f)))))) 
		   (cond (form `(,(meter:unprocess form)
				 .,(meter:unprocess (cdr f))))
			 (t (meter:unprocess (cdr f))))))
	     ((eq (caar f) 'mn)
	      (let ((form
		     (cond ((null (cdddr (car f))) ())
			   ((null (cdr (cdddr (car f))))
			    ())
			   (t 
			    (cadddr (cdr (car f)))))))
		   (cond (form `(,(meter:unprocess form)
				 .,(meter:unprocess (cdr f))))
			 (t (meter:unprocess (cdr f))))))
	     (t `(,(meter:unprocess (car f))
		  . ,(meter:unprocess (cdr f))))))

(defmacro meter:inc (name index incr)
	  `(store (,name ,index)
		  (+ (,name ,index) ,incr)))

(defun (push meter:expand-code) (form l avoid)
       (let ((q (gensym)))
	    `((,q) (push ,q ,(caddr form)) 
		   (,(meter:meter-funs l avoid (cadr form))))))

(defun (setq meter:expand-code) (form l avoid)
       (do ((form (cdr form) (cddr form))
	    (sym ())
	    (vals ())
	    (vars ())
	    (args ()))
	   ((null form)
	    `(,(reverse vars) (setq .,(reverse args)) ,(reverse vals)))
	   (push (car form) args)
	   (cond ((not (atom (cadr form)))
		  (push (meter:meter-funs l avoid (cadr form)) vals)
		  (setq sym (gensym))
		  (push sym args)
		  (push sym vars))
		 (t (push (cadr form) args)))))
;;; Here's a typical file:

;(declare 
; (fasload meter fas))
;
;(meter:meter baz
;	     (meter-funs ((+ "+'s")(= "='s")(foo "Calls to FOO"))
;			 (defun baz (n)
;				(do ((n n (1- n))
;				     (a 0))
;				    ((= n 0) a)
;				    (foo n)
;				    (setq a (+ a n)))) )
; 	     (meter-funs ((+ "+'s")(= "='s"))
;			 (defun foo (n)
;				(do ((n n (1- n))
;				     (a 0))
;				    ((= n 0) a)
;				    (setq a (+ a n))))))